home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / macros.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  8.0 KB  |  349 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     macros.c
  24. */
  25.  
  26. #include "include.h"
  27.  
  28.  
  29. object Swarn;
  30.  
  31. object siVinhibit_macro_special;
  32.  
  33. siLdefine_macro()
  34. {
  35.     check_arg(2);
  36.     if (type_of(vs_base[0]) != t_symbol)
  37.         not_a_symbol(vs_base[0]);
  38.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) {
  39.         if (vs_base[0]->s.s_mflag) {
  40.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  41.                 vs_base[0]->s.s_sfdef = NOT_SPECIAL;
  42.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  43.             FEerror("~S, a special form, cannot be redefined.",
  44.                 1, vs_base[0]);
  45.     }
  46.     clear_compiler_properties(vs_base[0],MMcaddr(vs_base[1]));
  47.     if (vs_base[0]->s.s_hpack == lisp_package &&
  48.         vs_base[0]->s.s_gfdef != OBJNULL && initflag) {
  49.         vs_push(make_simple_string(
  50.             "~S is being redefined."));
  51.         ifuncall2(Swarn, vs_head, vs_base[0]);
  52.         vs_pop;
  53.     }
  54.     vs_base[0]->s.s_gfdef = MMcaddr(vs_base[1]);
  55.     vs_base[0]->s.s_mflag = TRUE;
  56.     if (MMcar(vs_base[1]) != Cnil) {
  57.         vs_base[0]->s.s_plist
  58.         = putf(vs_base[0]->s.s_plist,
  59.                MMcar(vs_base[1]),
  60.                siSfunction_documentation);
  61.     }
  62.     if (MMcadr(vs_base[1]) != Cnil) {
  63.         vs_base[0]->s.s_plist
  64.         = putf(vs_base[0]->s.s_plist,
  65.                MMcadr(vs_base[1]),
  66.                siSpretty_print_format);
  67.     }
  68.     vs_top = vs_base+1;
  69. }
  70.  
  71. Fdefmacro(form)
  72. object form;
  73. {
  74.     object *top = vs_top;
  75.     object name;
  76.  
  77.     if (endp(form) || endp(MMcdr(form)))
  78.         FEtoo_few_argumentsF(form);
  79.     name = MMcar(form);
  80.     if (type_of(name) != t_symbol)
  81.         not_a_symbol(name);
  82.     vs_push(ifuncall3(siSdefmacroA,
  83.               name,
  84.               MMcadr(form),
  85.               MMcddr(form)));
  86.     if (MMcar(top[0]) != Cnil)
  87.         name->s.s_plist
  88.         = putf(name->s.s_plist,
  89.                MMcar(top[0]),
  90.                siSfunction_documentation);
  91.     if (MMcadr(top[0]) != Cnil)
  92.         name->s.s_plist
  93.         = putf(name->s.s_plist,
  94.                MMcadr(top[0]),
  95.                siSpretty_print_format);
  96.     if (name->s.s_sfdef != NOT_SPECIAL) {
  97.         if (name->s.s_mflag) {
  98.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  99.                 name->s.s_sfdef = NOT_SPECIAL;
  100.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  101.             FEerror("~S, a special form, cannot be redefined.",
  102.                 1, name);
  103.     }
  104.     clear_compiler_properties(name,MMcaddr(top[0]));
  105.     if (name->s.s_hpack == lisp_package &&
  106.         name->s.s_gfdef != OBJNULL && initflag) {
  107.         vs_push(make_simple_string(
  108.             "~S is being redefined."));
  109.         ifuncall2(Swarn, vs_head, name);
  110.         vs_pop;
  111.     }
  112.     name->s.s_gfdef = MMcaddr(top[0]);
  113.     name->s.s_mflag = TRUE;
  114.     vs_base = vs_top = top;
  115.     vs_push(name);
  116. }
  117.  
  118. /*
  119.     MACRO_EXPAND1 is an internal function which simply applies the
  120.     function EXP_FUN to FORM.  On return, the expanded form is stored
  121.     in VS_BASE[0].
  122. */
  123. macro_expand1(exp_fun, form)
  124. object exp_fun,form;
  125. {
  126.     vs_base = vs_top;
  127.     vs_push(exp_fun);
  128.     vs_push(form);
  129. /***/
  130. /*    
  131.     Macros may well need their functional environment to expand properly.
  132.     For example setf needs to expand the place which may be a local
  133.     macro.  They are not supposed to need the other parts of the
  134.     environment
  135. */
  136. #define VS_PUSH_ENV \
  137.     if(lex_env[1]){ \
  138.       vs_push(list(3,lex_env[0],lex_env[1],lex_env[2]));} \
  139.     else {vs_push(Cnil);}
  140.         VS_PUSH_ENV ;
  141. /***/
  142.     super_funcall(symbol_value(Vmacroexpand_hook));
  143.     if (vs_top == vs_base)
  144.         vs_push(Cnil);
  145. }
  146.  
  147. /*
  148.     MACRO_DEF is an internal function which, given a form, returns
  149.     the expansion function if the form is a macro form.  Otherwise,
  150.     MACRO_DEF returns NIL.
  151. */
  152. object
  153. macro_def(form)
  154. object form;
  155. {
  156.     object head, fd;
  157.  
  158.     if (type_of(form) != t_cons)
  159.         return(Cnil);
  160.     head = MMcar(form);
  161.     if (type_of(head) != t_symbol)
  162.         return(Cnil);
  163.     fd = lex_fd_sch(head);
  164.     if (MMnull(fd))
  165.         if (head->s.s_mflag)
  166.             return(head->s.s_gfdef);
  167.         else
  168.             return(Cnil);
  169.     else if (MMcadr(fd) == Smacro)
  170.         return(MMcaddr(fd));
  171.     else
  172.         return(Cnil);
  173. }
  174.  
  175. Lmacroexpand()
  176. {
  177.     object exp_fun, env;
  178.     object *base = vs_base;
  179.     object *lex=lex_env;
  180.  
  181.     lex_env = vs_top;
  182.     if (vs_top-vs_base < 1)
  183.         too_few_arguments();
  184.     else if (vs_top-vs_base == 1) {
  185.         vs_top[0] = vs_top[1] = vs_top[2] = Cnil;
  186.         vs_top += 3;
  187.     } else if (vs_top - vs_base == 2) {
  188.         env = vs_base[1];
  189.         vs_push(car(env));
  190.         env = cdr(env);
  191.         vs_push(car(env));
  192.         env = cdr(env);
  193.         vs_push(car(env));
  194.     } else
  195.         too_many_arguments();
  196.     exp_fun = macro_def(base[0]);
  197.     if (MMnull(exp_fun)) {
  198.         lex_env = lex;
  199.         vs_base = base;
  200.         vs_top = base + 1;
  201.         vs_push(Cnil);
  202.     } else {
  203.         object *top = vs_top;
  204.  
  205.         do {
  206.             macro_expand1(exp_fun, base[0]);
  207.             base[0] = vs_base[0];
  208.             vs_top = top;
  209.             exp_fun = macro_def(base[0]);
  210.         } while (!MMnull(exp_fun));
  211.         lex_env = lex;
  212.         vs_base = base;
  213.         vs_top = base+1;
  214.         vs_push(Ct);
  215.     }
  216. }
  217.  
  218. Lmacroexpand_1()
  219. {
  220.     object exp_fun;
  221.     object *base=vs_base;
  222.     object *lex=lex_env;
  223.  
  224.     lex_env = vs_top;
  225.     if (vs_top-vs_base<1)
  226.         too_few_arguments();
  227.     else if (vs_top-vs_base == 1) {
  228.         vs_push(Cnil);
  229.         vs_push(Cnil);
  230.         vs_push(Cnil);
  231.     } else if (vs_top-vs_base == 2) {
  232.         vs_push(car(vs_base[1]));
  233.         vs_push(car(cdr(vs_base[1])));
  234.         vs_push(car(cdr(cdr(vs_base[1]))));
  235.     } else
  236.         too_many_arguments();
  237.     exp_fun = macro_def(base[0]);
  238.     if (MMnull(exp_fun)) {
  239.         lex_env = lex;
  240.         vs_base = base;
  241.         vs_top = base+1;
  242.         vs_push(Cnil);
  243.     } else {
  244.         macro_expand1(exp_fun, base[0]);
  245.         base[0] = vs_base[0];
  246.         lex_env = lex;
  247.         vs_base = base;
  248.         vs_top = base+1;
  249.         vs_push(Ct);
  250.     }
  251. }
  252.  
  253. /*
  254.     MACRO_EXPAND is an internal function which, given a form, expands it
  255.     as many times as possible and returns the finally expanded form.
  256.     The argument 'form' need not be marked for GBC and the result is not
  257.     marked.
  258. */
  259. object
  260. macro_expand(form)
  261. object form;
  262. {
  263.     object exp_fun, head, fd;
  264.     object *base = vs_base;
  265.     object *top = vs_top;
  266.  
  267.     /* Check if the given form is a macro form.  If not, return
  268.        immediately.  Macro definitions are superseded by special-
  269.        form definitions.
  270.     */
  271.     if (type_of(form) != t_cons)
  272.         return(form);
  273.     head = MMcar(form);
  274.     if (type_of(head) != t_symbol)
  275.         return(form);
  276.     if (head->s.s_sfdef != NOT_SPECIAL)
  277.         return(form);
  278.     fd = lex_fd_sch(head);
  279.     if (MMnull(fd))
  280.         if (head->s.s_mflag)
  281.             exp_fun = head->s.s_gfdef;
  282.         else
  283.             return(form);
  284.     else if (MMcadr(fd) == Smacro)
  285.         exp_fun = MMcaddr(fd);
  286.     else
  287.         return(form);
  288.     
  289.     vs_top = top;
  290.     vs_push(form);            /* saves form in top[0] */
  291.     vs_push(exp_fun);        /* saves exp_fun in top[1] */
  292. LOOP:
  293.     /*  macro_expand1(exp_fun, form);  */
  294.     vs_base = vs_top;
  295.     vs_push(exp_fun);
  296.     vs_push(form);
  297. /***/
  298. /*    vs_push(Cnil); */
  299.     VS_PUSH_ENV ;
  300. /***/
  301.     super_funcall(symbol_value(Vmacroexpand_hook));
  302.     if (vs_base == vs_top)
  303.         vs_push(Cnil);
  304.     top[0] = form = vs_base[0];
  305.     /* Check if the expanded form is again a macro form.  If not,
  306.        reset the stack and return.
  307.     */
  308.     if (type_of(form) != t_cons)
  309.         goto END;
  310.     head = MMcar(form);
  311.     if (type_of(head) != t_symbol)
  312.         goto END;
  313.     if (head->s.s_sfdef != NOT_SPECIAL)
  314.         goto END;
  315.     fd=lex_fd_sch(head);
  316.     if (MMnull(fd))
  317.         if (head->s.s_mflag)
  318.             exp_fun = head->s.s_gfdef;
  319.         else
  320.             goto END;
  321.     else if (MMcadr(fd) == Smacro)
  322.         exp_fun = MMcaddr(fd);
  323.     else
  324.         goto END;
  325.     /* The expanded form is a macro form.  Continue expansion.  */
  326.     top[1] = exp_fun;
  327.     vs_top = top + 2;
  328.     goto LOOP;
  329. END:
  330.     vs_base = base;
  331.     vs_top = top;
  332.     return(form);
  333. }
  334.  
  335. init_macros()
  336. {
  337.     make_si_function("DEFINE-MACRO", siLdefine_macro);
  338.     Vmacroexpand_hook
  339.     = make_special("*MACROEXPAND-HOOK*", Sfuncall);
  340.     make_function("MACROEXPAND", Lmacroexpand);
  341.     make_function("MACROEXPAND-1", Lmacroexpand_1);
  342.     make_special_form("DEFMACRO", Fdefmacro);
  343.     siSdefmacroA = make_si_ordinary("DEFMACRO*");
  344.     enter_mark_origin(&siSdefmacroA);
  345.  
  346.     siVinhibit_macro_special =
  347.     make_si_special("*INHIBIT-MACRO-SPECIAL*", Cnil);
  348. }
  349.